home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / objdef.lisp < prev    next >
Encoding:
Text File  |  1992-02-26  |  13.9 KB  |  470 lines
  1. ;;; -*- Package: VM; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: objdef.lisp,v 1.16 92/02/26 00:56:53 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: objdef.lisp,v 1.16 92/02/26 00:56:53 wlott Exp $
  15. ;;;
  16. ;;; This file contains the machine independent aspects of the object
  17. ;;; representation.
  18. ;;;
  19. ;;; Written by William Lott.
  20. ;;;
  21. (in-package "VM")
  22.  
  23. (export '(lowtag-bits lowtag-mask lowtag-limit type-bits type-mask
  24.       target-most-positive-fixnum target-most-negative-fixnum
  25.       even-fixnum-type function-pointer-type other-immediate-0-type
  26.       list-pointer-type odd-fixnum-type structure-pointer-type
  27.       other-immediate-1-type other-pointer-type bignum-type ratio-type
  28.       single-float-type double-float-type complex-type
  29.       simple-array-type simple-string-type simple-bit-vector-type
  30.       simple-vector-type simple-array-unsigned-byte-2-type
  31.       simple-array-unsigned-byte-4-type
  32.       simple-array-unsigned-byte-8-type
  33.       simple-array-unsigned-byte-16-type
  34.       simple-array-unsigned-byte-32-type simple-array-single-float-type
  35.       simple-array-double-float-type complex-string-type
  36.       complex-bit-vector-type complex-vector-type complex-array-type
  37.       code-header-type function-header-type closure-header-type
  38.       closure-function-header-type return-pc-header-type
  39.       value-cell-header-type symbol-header-type base-char-type
  40.       sap-type unbound-marker-type weak-pointer-type
  41.       structure-header-type funcallable-instance-header-type
  42.       vector-normal-subtype
  43.       vector-valid-hashing-subtype vector-must-rehash-subtype
  44.       primitive-object primitive-object-p
  45.       primitive-object-name primitive-object-header
  46.       primitive-object-lowtag primitive-object-options
  47.       primitive-object-slots primitive-object-size
  48.       primitive-object-variable-length slot-name slot-docs slot-rest-p
  49.       slot-offset slot-length slot-options *primitive-objects*
  50.       define-for-each-primitive-object))
  51.  
  52. (in-package "KERNEL")
  53. (export '(%set-funcallable-instance-function %make-funcallable-instance))
  54.  
  55. (in-package "VM")
  56.  
  57.  
  58. ;;;; Type based constants:
  59.  
  60. (eval-when (compile eval load)
  61.  
  62. (defconstant lowtag-bits 3
  63.   "Number of bits at the low end of a pointer used for type information.")
  64.  
  65. (defconstant lowtag-mask (1- (ash 1 lowtag-bits))
  66.   "Mask to extract the low tag bits from a pointer.")
  67.   
  68. (defconstant lowtag-limit (ash 1 lowtag-bits)
  69.   "Exclusive upper bound on the value of the low tag bits from a
  70.   pointer.")
  71.  
  72. (defconstant type-bits 8
  73.   "Number of bits used in the header word of a data block for typeing.")
  74.  
  75. (defconstant type-mask (1- (ash 1 type-bits))
  76.   "Mask to extract the type from a header word.")
  77.  
  78. ); eval-when
  79.  
  80.  
  81. (defparameter target-most-positive-fixnum (1- (ash 1 29))
  82.   "most-positive-fixnum in the target architecture.")
  83.  
  84. (defparameter target-most-negative-fixnum (ash -1 29)
  85.   "most-negative-fixnum in the target architecture.")
  86.  
  87.  
  88. ;;; The main types.  These types are represented by the low three bits of the
  89. ;;; pointer or immeditate object.
  90. ;;; 
  91. (defenum (:suffix -type)
  92.   even-fixnum
  93.   function-pointer
  94.   other-immediate-0
  95.   list-pointer
  96.   odd-fixnum
  97.   structure-pointer
  98.   other-immediate-1
  99.   other-pointer)
  100.  
  101. ;;; The heap types.  Each of these types is in the header of objects in
  102. ;;; the heap.
  103. ;;; 
  104. (defenum (:suffix -type
  105.       :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
  106.       :step (ash 1 (1- lowtag-bits)))
  107.   bignum
  108.   ratio
  109.   single-float
  110.   double-float
  111.   complex
  112.   
  113.   simple-array
  114.   simple-string
  115.   simple-bit-vector
  116.   simple-vector
  117.   simple-array-unsigned-byte-2
  118.   simple-array-unsigned-byte-4
  119.   simple-array-unsigned-byte-8
  120.   simple-array-unsigned-byte-16
  121.   simple-array-unsigned-byte-32
  122.   simple-array-single-float
  123.   simple-array-double-float
  124.   complex-string
  125.   complex-bit-vector
  126.   complex-vector
  127.   complex-array
  128.   
  129.   code-header
  130.   function-header
  131.   closure-header
  132.   funcallable-instance-header
  133.   unused-function-header-1
  134.   unused-function-header-2
  135.   unused-function-header-3
  136.   closure-function-header
  137.   return-pc-header
  138.   value-cell-header
  139.   symbol-header
  140.   base-char
  141.   sap
  142.   unbound-marker
  143.   weak-pointer
  144.   structure-header)
  145.  
  146.  
  147. ;;; The different vector subtypes.
  148. ;;; 
  149. (defenum (:prefix vector- :suffix -subtype)
  150.   normal
  151.   unused
  152.   valid-hashing
  153.   must-rehash)
  154.  
  155.  
  156.  
  157.  
  158. ;;;; Primitive data objects definition noise.
  159.  
  160. (eval-when (compile load eval)
  161.  
  162. (defstruct (prim-object-slot
  163.         (:conc-name slot-)
  164.         (:constructor %make-slot
  165.               (name docs rest-p length options))
  166.         (:make-load-form-fun :just-dump-it-normally))
  167.   (name nil :type symbol)
  168.   (docs nil :type (or null simple-string))
  169.   (rest-p nil :type (member t nil))
  170.   (offset 0 :type fixnum)
  171.   (length 1 :type fixnum)
  172.   (options nil :type list))
  173.  
  174. (defun make-slot (name &rest options
  175.                &key docs rest-p (length (if rest-p 0 1))
  176.                &allow-other-keys)
  177.   (let ((options (copy-list options)))
  178.     (remf options :docs)
  179.     (remf options :rest-p)
  180.     (remf options :length)
  181.     (%make-slot name docs rest-p length options)))
  182.  
  183. (defstruct (primitive-object
  184.         (:make-load-form-fun :just-dump-it-normally))
  185.   (name nil :type symbol)
  186.   (header nil :type symbol)
  187.   (lowtag nil :type symbol)
  188.   (options nil :type list)
  189.   (slots nil :type list)
  190.   (size 0 :type fixnum)
  191.   (variable-length nil :type (member t nil)))
  192.  
  193.  
  194. (defvar *primitive-objects* nil)
  195.  
  196. ); eval-when (compile load eval)
  197.  
  198.  
  199. (defmacro define-primitive-object ((name &rest options
  200.                      &key header lowtag
  201.                      &allow-other-keys)
  202.                    &rest slots)
  203.   (setf options (copy-list options))
  204.   (remf options :header)
  205.   (remf options :lowtag)
  206.   (let ((prim-obj
  207.      (make-primitive-object :name name
  208.                 :header header
  209.                 :lowtag lowtag
  210.                 :options options
  211.                 :slots (mapcar #'(lambda (slot)
  212.                            (if (atom slot)
  213.                                (make-slot slot)
  214.                                (apply #'make-slot
  215.                                   slot)))
  216.                            slots))))
  217.     (collect ((forms) (exports))
  218.       (let ((offset (if (primitive-object-header prim-obj) 1 0))
  219.         (variable-length nil))
  220.     (dolist (slot (primitive-object-slots prim-obj))
  221.       (when variable-length
  222.         (error "~S is anything after a :rest-p t slot." slot))
  223.       (let* ((rest-p (slot-rest-p slot))
  224.          (offset-sym
  225.           (intern (concatenate 'simple-string
  226.                        (string name)
  227.                        "-"
  228.                        (string (slot-name slot))
  229.                        (if rest-p "-OFFSET" "-SLOT")))))
  230.         (forms `(defconstant ,offset-sym ,offset
  231.               ,@(when (slot-docs slot) (list (slot-docs slot)))))
  232.         (setf (slot-offset slot) offset)
  233.         (exports offset-sym)
  234.         (incf offset (slot-length slot))
  235.         (when rest-p (setf variable-length t))))
  236.     (setf (primitive-object-variable-length prim-obj) variable-length)
  237.     (unless variable-length
  238.       (let ((size (intern (concatenate 'simple-string
  239.                        (string name)
  240.                        "-SIZE"))))
  241.         (forms `(defconstant ,size ,offset
  242.               ,(format nil
  243.                    "Number of slots used by each ~S~
  244.                    ~@[~* including the header~]."
  245.                    name header)))
  246.         (exports size)))
  247.     (setf (primitive-object-size prim-obj) offset))
  248.       `(eval-when (compile load eval)
  249.      (setf *primitive-objects*
  250.            (cons ',prim-obj
  251.              (delete ',name *primitive-objects*
  252.                  :key #'primitive-object-name)))
  253.      (export ',(exports))
  254.      ,@(forms)))))
  255.  
  256. (defmacro define-for-each-primitive-object ((var) &body body)
  257.   (let ((name (gensym)))
  258.     `(macrolet ((,name (,var) ,@body))
  259.        ,@(mapcar #'(lambda (x)
  260.              `(,name ,x))
  261.          *primitive-objects*))))
  262.  
  263.  
  264. ;;;; The primitive objects themselves.
  265.  
  266.  
  267. (define-primitive-object (cons :lowtag list-pointer-type
  268.                    :alloc-trans cons)
  269.   (car :ref-vop car :ref-trans car
  270.        :setf-vop c::set-car :set-trans c::%rplaca
  271.        :init :arg)
  272.   (cdr :ref-vop cdr :ref-trans cdr
  273.        :setf-vop set-cdr :set-trans c::%rplacd
  274.        :init :arg))
  275.  
  276. (define-primitive-object (structure :lowtag structure-pointer-type
  277.                     :header structure-header-type
  278.                     :alloc-trans make-structure)
  279.   (slots :rest-p t))
  280.  
  281. (define-primitive-object (bignum :lowtag other-pointer-type
  282.                  :header bignum-type
  283.                  :alloc-trans bignum::%allocate-bignum)
  284.   (digits :rest-p t :c-type "long"))
  285.  
  286. (define-primitive-object (ratio :lowtag other-pointer-type
  287.                 :header ratio-type
  288.                 :alloc-vop c::make-ratio
  289.                 :alloc-trans %make-ratio)
  290.   (numerator :ref-vop numerator :init :arg)
  291.   (denominator :ref-vop denominator :init :arg))
  292.  
  293. (define-primitive-object (single-float :lowtag other-pointer-type
  294.                        :header single-float-type)
  295.   (value :c-type "float"))
  296.  
  297. (define-primitive-object (double-float :lowtag other-pointer-type
  298.                        :header double-float-type)
  299.   (filler)
  300.   (value :c-type "double" :length 2))
  301.  
  302. (define-primitive-object (complex :lowtag other-pointer-type
  303.                   :header complex-type
  304.                   :alloc-vop c::make-complex
  305.                   :alloc-trans %make-complex)
  306.   (real :ref-vop realpart :init :arg)
  307.   (imag :ref-vop imagpart :init :arg))
  308.  
  309. (define-primitive-object (array :lowtag other-pointer-type
  310.                 :header t)
  311.   (fill-pointer :type index
  312.         :ref-trans %array-fill-pointer
  313.         :ref-known (flushable foldable)
  314.         :set-trans (setf %array-fill-pointer)
  315.         :set-known (unsafe))
  316.   (fill-pointer-p :type (member t nil)
  317.           :ref-trans %array-fill-pointer-p
  318.           :ref-known (flushable foldable)
  319.           :set-trans (setf %array-fill-pointer-p)
  320.           :set-known (unsafe))
  321.   (elements :type index
  322.         :ref-trans %array-available-elements
  323.         :ref-known (flushable foldable)
  324.         :set-trans (setf %array-available-elements)
  325.         :set-known (unsafe))
  326.   (data :type array
  327.     :ref-trans %array-data-vector
  328.     :ref-known (flushable foldable)
  329.     :set-trans (setf %array-data-vector)
  330.     :set-known (unsafe))
  331.   (displacement :type (or index null)
  332.         :ref-trans %array-displacement
  333.         :ref-known (flushable foldable)
  334.         :set-trans (setf %array-displacement)
  335.         :set-known (unsafe))
  336.   (displaced-p :type (member t nil)
  337.            :ref-trans %array-displaced-p
  338.            :ref-known (flushable foldable)
  339.            :set-trans (setf %array-displaced-p)
  340.            :set-known (unsafe))
  341.   (dimensions :rest-p t))
  342.  
  343. (define-primitive-object (vector :lowtag other-pointer-type :header t)
  344.   (length :ref-trans c::vector-length
  345.       :type index
  346.       :ref-known (flushable foldable))
  347.   (data :rest-p t :c-type "unsigned long"))
  348.  
  349. (define-primitive-object (code :lowtag other-pointer-type :header t)
  350.   (code-size :ref-vop c::code-code-size)
  351.   (entry-points :ref-vop c::code-entry-points
  352.         :set-vop c::set-code-entry-points)
  353.   (debug-info :type t
  354.           :ref-trans di::code-debug-info
  355.           :ref-known (flushable)
  356.           :set-vop c::set-code-debug-info)
  357.   (trace-table-offset)
  358.   (constants :rest-p t))
  359.  
  360. (define-primitive-object (function-header :lowtag function-pointer-type
  361.                       :header function-header-type)
  362.   (self :ref-vop c::function-self :set-vop c::set-function-self)
  363.   (next :ref-vop c::function-next :set-vop c::set-function-next)
  364.   (name :ref-vop c::function-name
  365.     :ref-known (flushable)
  366.     :ref-trans %function-header-name
  367.     :set-vop c::set-function-name)
  368.   (arglist :ref-vop c::function-arglist
  369.        :ref-known (flushable)
  370.        :ref-trans lisp::%function-header-arglist
  371.        :set-vop c::set-function-arglist)
  372.   (type :ref-vop c::function-type
  373.     :ref-known (flushable)
  374.     :ref-trans lisp::%function-header-type
  375.     :set-vop c::set-function-type)
  376.   (code :rest-p t :c-type "unsigned char"))
  377.  
  378. (define-primitive-object (return-pc :lowtag other-pointer-type :header t)
  379.   (return-point :c-type "unsigned char" :rest-p t))
  380.  
  381. (define-primitive-object (closure :lowtag function-pointer-type
  382.                   :header closure-header-type
  383.                   :alloc-vop c::make-closure)
  384.   (function :init :arg
  385.         :ref-vop c::closure-function
  386.         :ref-known (flushable)
  387.         :ref-trans %closure-function)
  388.   (info :rest-p t :set-vop c::closure-init :ref-vop c::closure-ref))
  389.  
  390. (define-primitive-object (funcallable-instance
  391.               :lowtag function-pointer-type
  392.               :header funcallable-instance-header-type
  393.               :alloc-vop make-funcallable-instance
  394.               :alloc-trans %make-funcallable-instance)
  395.   (function :init :arg
  396.         :set-vop set-funcallable-instance-function
  397.         :set-trans %set-funcallable-instance-function
  398.         :set-known (unsafe))
  399.   (info :rest-p t))
  400.  
  401. (define-primitive-object (value-cell :lowtag other-pointer-type
  402.                      :header value-cell-header-type
  403.                      :alloc-vop make-value-cell
  404.                      :alloc-trans make-value-cell)
  405.   (value :set-vop value-cell-set
  406.      :set-trans value-cell-set
  407.      :set-known (unsafe)
  408.      :ref-vop value-cell-ref
  409.      :ref-trans value-cell-ref
  410.      :ref-known (flushable)
  411.      :init :arg))
  412.  
  413. (define-primitive-object (symbol :lowtag other-pointer-type
  414.                  :header symbol-header-type)
  415.   (value :set-trans %set-symbol-value
  416.      :setf-vop set)
  417.   (function)
  418.   (raw-function-addr :c-type "char *")
  419.   (setf-function)
  420.   (plist :ref-trans symbol-plist
  421.      :setf-vop %set-symbol-plist
  422.      :set-trans %set-symbol-plist)
  423.   (name :ref-trans symbol-name)
  424.   (package :ref-trans symbol-package
  425.        :setf-vop %set-symbol-package
  426.        :set-trans %set-symbol-package))
  427.  
  428. (define-primitive-object (sap :lowtag other-pointer-type
  429.                   :header sap-type)
  430.   (pointer :c-type "char *"))
  431.  
  432.  
  433. (define-primitive-object (weak-pointer :lowtag other-pointer-type
  434.                        :header weak-pointer-type
  435.                        :alloc-trans c::%make-weak-pointer)
  436.   (value :ref-trans c::%weak-pointer-value
  437.      :ref-known (flushable)
  438.      :set-trans (setf c::%weak-pointer-value)
  439.      :set-known (unsafe)
  440.      :init :arg)
  441.   (broken :ref-trans c::%weak-pointer-broken
  442.       :ref-known (flushable)
  443.       :set-trans (setf c::%weak-pointer-broken)
  444.       :set-known (unsafe)
  445.       :init :arg)
  446.   (next :c-type "struct weak_pointer *"))
  447.   
  448.  
  449. ;;; Other non-heap data blocks.
  450.  
  451. (define-primitive-object (binding)
  452.   value
  453.   symbol)
  454.  
  455. (define-primitive-object (unwind-block)
  456.   (current-uwp :c-type "struct unwind_block *")
  457.   (current-cont :c-type "lispobj *")
  458.   current-code
  459.   entry-pc)
  460.  
  461. (define-primitive-object (catch-block)
  462.   (current-uwp :c-type "struct unwind_block *")
  463.   (current-cont :c-type "lispobj *")
  464.   current-code
  465.   entry-pc
  466.   tag
  467.   (previous-catch :c-type "struct catch_block *")
  468.   size)
  469.  
  470.